home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Interactive Reference Guide / C-C++ Interactive Reference Guide.iso / c_ref / csource5 / 349_01 / sss.arc / EX_0702.FOR < prev    next >
Encoding:
Text File  |  1991-04-10  |  4.5 KB  |  198 lines
  1. C     Program EX_0702.FOR
  2. C     Listing 15F - see documentation in TUTOR.SSS
  3.  
  4. $include:'SSSF1.H'
  5.  
  6.       subroutine prime
  7. $include:'SSSF2.H'
  8.       integer ARRIVL, STARTA, ENDACT, NEXTAC, MATCH,
  9.      +  MAINP, COVER, MREQ, server
  10.       real*8  WHITE, BLUE, RED, YELLOW
  11.       common  ARRIVL, STARTA, ENDACT, NEXTAC, MATCH,
  12.      +  WHITE, BLUE, RED, YELLOW, MAINP, COVER, MREQ,
  13.      +  server
  14.  
  15.       ARRIVL = 1
  16.       STARTA = 2
  17.       ENDACT = 3
  18.       NEXTAC = 4
  19.       MATCH  = 5
  20.  
  21.       WHITE  = 1.0
  22.       BLUE   = 2.0
  23.       RED    = 3.0
  24.       YELLOW = 4.0
  25.       MAINP  = 1
  26.       COVER  = 2
  27.       MREQ   = 3
  28.       server = 1
  29.  
  30.       call INIQUE(2, 1, 1)
  31.       call SIMEND(150.0)
  32.       call CREATE(EX(12.0), MAINP)
  33.       call CREATE(EX(12.0), COVER)
  34.       return
  35.       end
  36.  
  37.       integer function other
  38. $include:'SSSF2.H'
  39.       integer ARRIVL, STARTA, ENDACT, NEXTAC, MATCH,
  40.      +  MAINP, COVER, MREQ, server
  41.       real*8  WHITE, BLUE, RED, YELLOW
  42.       common  ARRIVL, STARTA, ENDACT, NEXTAC, MATCH,
  43.      +  WHITE, BLUE, RED, YELLOW, MAINP, COVER, MREQ,
  44.      +  server
  45.  
  46.       if (IDE().eq.MAINP) then
  47.         other = COVER
  48.       else
  49.         other = MAINP
  50.       endif
  51.       return
  52.       end
  53.  
  54.       subroutine find1
  55. $include:'SSSF2.H'
  56.  
  57.       integer ARRIVL, STARTA, ENDACT, NEXTAC, MATCH,
  58.      +  MAINP, COVER, MREQ, server
  59.       real*8  WHITE, BLUE, RED, YELLOW
  60.       common  ARRIVL, STARTA, ENDACT, NEXTAC, MATCH,
  61.      +  WHITE, BLUE, RED, YELLOW, MAINP, COVER, MREQ,
  62.      +  server
  63.       integer o, other
  64.  
  65.       i = 1
  66.       o = other()
  67.  99   continue
  68.       if ((i.lt.NQ(o)).and.(AIQ(o, i, 1).ne.A(1))) then
  69.         i = i + 1
  70.         goto 99
  71.       endif
  72.  
  73.       if (i.le.NQ(o)) then
  74.         call DISPOS
  75.         call REMVFQ(o, i)
  76.         call SCHED(0.0, STARTA, IDE())
  77.       else
  78.         call QUEUE(IDE(), 0.0)
  79.       endif
  80.       return
  81.       end
  82.  
  83.       subroutine find2
  84. $include:'SSSF2.H'
  85.  
  86.       integer ARRIVL, STARTA, ENDACT, NEXTAC, MATCH,
  87.      +  MAINP, COVER, MREQ, server
  88.       real*8  WHITE, BLUE, RED, YELLOW
  89.       common  ARRIVL, STARTA, ENDACT, NEXTAC, MATCH,
  90.      +  WHITE, BLUE, RED, YELLOW, MAINP, COVER, MREQ,
  91.      +  server
  92.       logical found
  93.       real*8  color
  94.  
  95.       found = .FALSE.
  96.       j = 1
  97.   99  continue
  98.         color = AIQ(MAINP, j, 1)
  99.         i = 1
  100.   88    continue
  101.         if ((i.lt.NQ(COVER)).and.
  102.      +      (AIQ(COVER, i, 1).ne.color)) then
  103.           i = i + 1
  104.           goto 88
  105.         endif
  106.  
  107.         if (i.le.NQ(COVER)) then
  108.           call REMVFQ(COVER, i)
  109.           call DISPOS
  110.           call REMVFQ(MAINP, j)
  111.           found = .TRUE.
  112.         else
  113.           j = j + 1
  114.         endif
  115.       if ((.not.found).and.(j.le.NQ(MAINP))) goto 99
  116.       return
  117.       end
  118.  
  119.       Program EX_0702
  120. $include:'SSSF2.H'
  121.       integer ARRIVL, STARTA, ENDACT, NEXTAC, MATCH,
  122.      +  MAINP, COVER, MREQ, server
  123.       real*8  WHITE, BLUE, RED, YELLOW
  124.       common  ARRIVL, STARTA, ENDACT, NEXTAC, MATCH,
  125.      +  WHITE, BLUE, RED, YELLOW, MAINP, COVER, MREQ,
  126.      +  server
  127.       integer ecode, other
  128.  
  129.       call prime
  130.  
  131.    99 ecode = NEXTEV()
  132.       if (ecode.gt.0) then
  133.         goto (101, 102, 103, 104, 105) ecode
  134.  
  135. C ARRIVL
  136.   101   continue
  137.         if (IDE().eq.MREQ) then
  138.           call SCHED(0.0, MATCH, IDE())
  139.  
  140.         else
  141.           call CREATE(EX(12), IDE())
  142.           if (RA().lt.0.35) then
  143.             call SETA(1, WHITE )
  144.           elseif (RA().lt.0.50) then
  145.             call SETA(1, BLUE  )
  146.           elseif (RA().lt.0.80) then
  147.             call SETA(1, RED   )
  148.           else
  149.             call SETA(1, YELLOW)
  150.           endif
  151.  
  152.           call SCHED(0.0, NEXTAC, IDE())
  153.         endif
  154.         goto 99
  155.  
  156. C NEXTAC
  157.   104   continue
  158.         if ((server.gt.0).and.(NQ(other()).gt.0)) then
  159.           call SCHED(0.0, MATCH, IDE())
  160.         else
  161.           call QUEUE(IDE(), 0.0)
  162.         endif
  163.         goto 99
  164.  
  165. C MATCH
  166.   105   continue
  167.         if (IDE().eq.MREQ) then
  168.           call DISPOS
  169.           call find2
  170.         else
  171.           call find1
  172.           if (NCEN().gt.0)
  173.      +      call SCHED(0.0, STARTA, IDE())
  174.         endif
  175.         goto 99
  176.  
  177. C STARTA
  178.   102   continue
  179.         server = server - 1
  180.         call SCHED(RN(10.0, 2.0), ENDACT, IDE())
  181.         goto 99
  182.  
  183. C ENDACT
  184.   103   continue
  185.         call DISPOS
  186.         server = server + 1
  187.         if ((NQ(MAINP).gt.0).and.(NQ(COVER).gt.0))
  188.      +    call CREATE(0.0, MREQ)
  189.         goto 99
  190.  
  191.       else
  192.  
  193.         call SUMRY(' ')
  194.         stop 'End of simulation'
  195.  
  196.       endif
  197.       end
  198.